package cldb;

use DBI;
use Carp qw(cluck);
use Data::Dumper;
use Fcntl ':flock';

#########################################################################
# Class level variables to record errors of last call.			#
#########################################################################

my $cldb_errcode=0;
my $cldb_errstr=undef;

#########################################################################
# Records is an array of known record types with details of each field	#
# including whether it is optional or not, and what kind of validation	#
# and manipulation to apply when attempting to add records via the	#
# add_verified_record method.						#
#########################################################################

my %records=(
	"globals" => {
		"var"		=> ["m",\&is_unique],
		"value"		=> ["m"]
		},
	"ports"	=> {
		"number"	=> ["m",\&is_unique,\&is_integer,\&is_nowhitespace],
		"type"		=> ["m"],
		"detail"	=> ["o"],
		},
	"topology" => {
		"name"		=> ["m",\&is_unique,\&is_nowhitespace],
		"lcards"	=> ["o"],
		"pcards"	=> ["o"],
		"type"		=> ["m",\&is_valid_nettype]
		},
	"applications" => {
		"name"		=> ["m",\&is_unique_app_in_cluster],
		"prefnode"	=> ["m",\&is_valid_app_preference],
		"nodes"		=> ["m",\&is_valid_node_list],
		"consistency"	=> ["m",\&is_valid_failover_type],
		"startscript"	=> ["o",\&is_valid_script],
		"stopscript"	=> ["o",\&is_valid_script],
		"migratescript"	=> ["o",\&is_valid_script],
		"starttimeout"	=> ["o",\&is_integer],
		"migratetimeout"=> ["o",\&is_integer],
		"stoptimeout"	=> ["o",\&is_integer],
		"storage"	=> ["m",\&is_valid_storage_spec],
		"lmigrate"	=> ["m",\&is_integer],
		},
	"application_ips" => {
		"name"		=> ["m",],
		"network"	=> ["m",],
		"ips"		=> ["m",],
		"netmask"	=> ["o",\&is_netmask],
		"broadcast"	=> ["o",\&is_ip_addr],
		"version"	=> ["o",\&is_4_or_6],
		},
	"application_fs" => {
		"name"		=> ["m",\&is_cluster_app],
		"mountpnt"	=> ["m"],
		"options"	=> ["o"],
		"fstype"	=> ["m",\&is_supported_fs],
		"vg"		=> ["m",\&is_existing_vg,\&is_unique_in_cluster],
		"lv"		=> ["m",\&is_existing_lv],
		"size"		=> ["m",\&is_integer],
	},
	"cluster_events" => {
		"name"		=> ["m",],
		"event"		=> ["m",\&is_valid_cluster_event],
		"text"		=> ["m",],
		"type"		=> ["m",\&is_valid_cluster_event_type],
		"send_host"	=> ["o"],
		"send_port"	=> ["o"],
		"send_email"	=> ["o"],
		"send_file"	=> ["o"],
		"send_cmd"	=> ["o"],
	},
	"locks" => {
		"name"		=> ["m",\&is_unique,\&is_nowhitespace],
		"type"		=> ["m",\&is_host_or_cluster],
		"desc"		=> ["m"],
		"maxtime"	=> ["m",\&is_integer],
		"maxkeepers"	=> ["m",\&is_integer],
	}
);

my %records_postadd=(
);

sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self  = {};
my $dbname=$_[0];
my $timeout=$_[1];

	if(!defined($dbname)) {
		$dbname="/etc/cluster/config.db";
	}
	if(!defined($timeout)) {
		$timeout=10;
	}
	$cldb_errcode=0;
	$cldb_errstr=undef;
	my $c=0;
	my $l=0;
	my $stime=time;
	while($c<$timeout) {
		if(!open(FD,">>$dbname")) {
			$cldb_errcode=1;
			$cldb_errstr="No permissons to open database '$dbname'.";
			return undef;
		}
		if(!flock(FD,LOCK_EX|LOCK_NB)) {
			select(undef,undef,undef,0.1);
			$c+=0.1;
		#	if($c%2==0) {
				::warning("cldb: Have waited $c seconds so far for lock.") if(defined(&::warning));
		#	}
			next;
		}
		$l=1;
		last;
	}
	if($l==0) {
		$cldb_errcode=1;
		$cldb_errstr="Unable to get lock on database $dbname!.";
			# ::msg("Unable to get lock on database $dbname!.");
		return undef;
	}
	if($c>=2) {
		::warning("cldb: Waited $c seconds to get database lock.") if(defined(&::warning));
	}
	close(FD);

	$self->{DBH}=DBI->connect("dbi:SQLite:dbname=$dbname","","",
			{RaiseError => 0,PrintError => 0,AutoCommit => 1});
	if(!defined($self->{DBH})) {
		$cldb_errcode=1;
		$cldb_errstr="Unable to connect to database $dbname!.";
		return undef;
	}
	$self->{FILENAME}=$dbname;
	bless($self,$class);
	return $self;
}

#########################################################################
# Class method to return the latest error (code,string), 		#
# or undef if last call was successful.					#
#########################################################################

sub error {
	return($cldb_errcode,$cldb_errstr);
}

#########################################################################
# Instance method to execute any old SQL against the current database.	#
#########################################################################

sub do($$;$) {
my $self=shift;
my $timeout=$_[2];

	$timeout=3 if !defined($timeout);
	$cldb_errcode=0;
	$cldb_errstr=undef;
	my $ctime=0;
	while($ctime<=$timeout) {
		$self->{DBH}->do($_[0]);
		if(defined($self->{DBH}->err) && $self->{DBH}->err==5) {
			$cldb_errcode=5;
			$cldb_errstr=$self->{DBH}->errstr;
			# locked error;
			$ctime+=0.10;
			select(undef,undef,undef,0.10);
			next;
		}
		my $rc=$self->{DBH}->errstr;
		if(defined($rc)) {
			$cldb_errcode=2;
			$cldb_errstr=$rc;
			return 0;
		}
		return 1;
	}
	return 0;
}

# Does nothing, since autocommit is now turned on

sub commit($) {
my $self=shift;

	$cldb_errcode=0;
	$cldb_errstr=undef;
}

sub disconnect {
my $self=shift;

	if(defined($self->{DBH})) {
		$self->{DBH}->disconnect;
	}
}

sub DESTROY {
my $self=shift;

	if(defined($self->{DBH})) {
		$self->{DBH}->disconnect;
	}
}

sub exists($$$) {
my $self=shift;
my ($type,$obj)=@_;
my ($cmd,$rc,$sth);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	$cmd="SELECT * FROM SQLITE_MASTER WHERE type = '$type' AND name = '$obj';";
	my $h=$self->{DBH}->selectrow_hashref("$cmd");
	if(!defined($h)) {
		return 0;
	}
	return 1;
}

#########################################################################
# The add_field adds a missing field to a table and populates any	#
# records with the specified default value. It does this by 		#
# taking the table defintion for the old table and adding a		#
# field and copying all records between the two.			#
#									#
# Once complete the old table is dropped and the new table is		#
# renamed to the correct name.						#
#									#
# Returns:								#
# -1 = specified table does not exist.					#
# -2 = unable to get field definitions for table.			#
# 1  = field already present; no work required.				#
# 10+ - field added, r-10 records updated.				#
#########################################################################

sub add_field($$$$$) {
my $self=shift;
my ($table,$field,$type,$value)=@_;

	my $z=$self->contains_field($table,$field);
	if($z!=0) {
		return $z;
	}
	# Get the table defintiion information..

	my ($x,$r1,$r2)=$self->table_field_list($table);
	if($x==0) {
		return -2;
	}
	my $cmd="create table ${table}_backup(\n";
	my $cmd2="create table ${table}(\n";
	my $ii=0;
	while($ii<@$r1) {
		$cmd2.="  $r1->[$ii] $r2->[$ii],\n";
		if($ii+1==@$r1) {
			$cmd.="  $r1->[$ii] $r2->[$ii]\n";
		} else {
			$cmd.="  $r1->[$ii] $r2->[$ii],\n";
		}
		$ii++;
	}
	$cmd.=");";
	$cmd2.="  $field $type\n);";

	my $DBH=$self->{DBH};
	$DBH->do($cmd);
	$cmd="insert into ${table}_backup SELECT " . join(",",@$r1) . " FROM $table;";
	$DBH->do($cmd);
	$cmd="DROP TABLE $table;";
	$DBH->do($cmd);
	$DBH->do($cmd2);
	# Read recrods from backup to new...
	$cmd="select * from ${table}_backup;";
	my @FLIST=(@$r1,$field);
	my $flist_txt=join(",",@FLIST);
	my $rr=$self->get_rows($cmd);
	my $count=0;
	for my $crec (@$rr) {
		$crec->{$field}=$value;
		$cmd="INSERT INTO $table ($flist_txt) VALUES (";
		my $cc="";
		for my $xxx (@FLIST) {
			$cc.=",'$crec->{$xxx}'";
		}
		$cmd.=substr($cc,1) . ");";
		$DBH->do($cmd);
		$count++;
	}
	$cmd="DROP TABLE ${table}_backup;";
	$DBH->do($cmd);
	return 10+$count;
}

#########################################################################
# Returns a list of field definition lines, with any , stripped off the	#
# end of the line.							#
# (0,[],[]) - no such table.						#
# (1,[field defs],[field names])					#
#########################################################################
sub table_field_list($$) {
my $self=shift;
my $table=shift;
my ($cmd,$rc,$sth);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$cmd="SELECT sql FROM SQLITE_MASTER WHERE type = 'table' AND name = '$table';";
	my $h=$self->{DBH}->selectrow_hashref("$cmd");
	if(!defined($h)) {
		return (0,[],[]); # table does not exist
	}
	my @F=split(/\n/,$h->{sql});
	my @FF=();
	my @FF2=();
	for my $cl (@F[1 .. $#F-1]) {
		my $y=$cl;
		$y =~ s/^\s+//;
		$y =~ s/,$//;
		my @YY=split(/\s+/,$y);
		push @FF,$YY[0];
		push @FF2,$YY[1];
	}
	return(1,[@FF],[@FF2]);
}

sub contains_field($$$) {
my $self=shift;
my ($obj,$field)=@_;
my ($cmd,$rc,$sth);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	$cmd="SELECT sql FROM SQLITE_MASTER WHERE type = 'table' AND name = '$obj';";
	my $h=$self->{DBH}->selectrow_hashref("$cmd");
	if(!defined($h)) {
		return -1; # table does not exist
	}
	my @F=split(/\n/,$h->{sql});
	for my $cl (@F[1 .. $#F-1]) {
		my $y=$cl;
		$y =~ s/^\s+//;
		my @F2=split(/\s+/,$y);
		if(lc($F2[0]) eq lc($field)) {
			return 1; # field already exists
		}
	}
	return 0; # field does not exist
}

sub get_rows($$) {
my ($self,$query)=@_;
my ($sth,$rc,@R,$aref);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$sth=$self->{DBH}->prepare($query);
	if(!defined($sth)) {
		$rc=$self->{DBH}->errstr;
		$cldb_errcode=5;
		$cldb_errstr=$rc;
		return undef;
	}
	$sth->execute();
	@R=();
	while($aref  = $sth->fetchrow_hashref) {
		push @R,{%$aref};
	}
	return \@R;
}

sub get_object_schema($$$) {
my ($self,$type,$obj)=@_;
my ($cmd,$aref,$sth,$rc);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	if(!defined($obj)) {
		$cldb_errcode=6;
		$cldb_errstr="Specified object value is undefined.";
		return undef;
	}
	$cmd="SELECT * FROM SQLITE_MASTER WHERE type = '$type' AND name = '$obj';";
	$sth=$self->{DBH}->prepare($cmd);
	if(!defined($sth)) {
		$rc=$self->{DBH}->errstr;
		$cldb_errcode=7;
		$cldb_errstr=$rc;
		return undef;
	}
	$sth->execute();
	if(!defined($aref=$sth->fetchrow_hashref)) {
		$cldb_errcode=8;
		$cldb_errstr="$obj of type $type does not exist.";
		return undef;
	}
	return $aref->{sql};
}

sub get_record_requirements {
my ($crec,$str);

	$str="";
	for $crec (sort(keys %records)) {
		$str.=sprintf("  * %-20s ::= ",$crec);
		my $ckey;
		for $ckey (keys(%{$records{$crec}})) {
			if($records{$crec}->{$ckey}->[0] eq "m") {
				$str.="$ckey ";
			}
		}
		for $ckey (keys(%{$records{$crec}})) {
			if($records{$crec}->{$ckey}->[0] eq "o") {
				$str.="[$ckey] ";
			}
		}
		$str.="\n";
	}
	return $str;
}

sub add_verified_record {
my $self=shift;
my $ARG_table=shift;
my @ARGV=@_;
local $DBH;		# For use in verifiation sub-routines
my %VALUES=();

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$DBH=$self->{DBH};

	my ($code,$val,$rc,$str);
	if(!exists($records{$ARG_table})) {
			$cldb_errcode=10;
			$cldb_errstr="Add_validated_record does not work on table '$ARG_table'.";
			return 0;
	}

	my %had=();
	foreach (@ARGV) {
		my $carg=$_;
		my ($field,$value)=split(/:/,$carg);
		$had{$field}=$value;
	}

	foreach (@ARGV) {
		my $carg=$_;
		my ($field,$value)=split(/:/,$carg);

		if(!exists($records{$ARG_table}->{$field})) {
			$cldb_errcode=10;
			$cldb_errstr="Column '$field' is not defined in table '$ARG_table'.";
			return 0;
		}

		#################################################################
		# If the field has one or more validation, formation tools,	#
		# then call it now.						#
		#################################################################

		for $code ((@{$records{$ARG_table}->{$field}})[1..9]) {
			next if !defined($code);
			next if $code eq "";
			($rc,$val)=&$code($ARG_table,$field,$value,\%had);
			if($rc) {
				$cldb_errcode=11;
				$cldb_errstr="$val";
				return 0;
			}
			$value=$val if defined($val);
		}
		$VALUES{$field}=$value;
	}

	#################################################################
	# Check to ensure that all mandatory fields have been specified	#
	# and if not then the process should abort with suitable error.	#
	#################################################################

	my @B=();
	my $ckey;
	for $ckey (keys(%{$records{$ARG_table}})) {
		if($records{$ARG_table}->{$ckey}->[0] eq "m" &&
			!exists($VALUES{$ckey})) {
			push @B,$ckey;
		}
	}
	if(@B) {
		$cldb_errcode=11;
		$cldb_errstr="Mandatory columns missing for new row on table '$ARG_table': ".join(",",@B);
		return 0;
	}

	#################################################################
	# Everything should now be in place to actually add the		#
	# record.							#
	#################################################################
	
	my $cmd="INSERT INTO $ARG_table(";
	$cmd.=join(",",(keys %VALUES));
	$cmd.=") VALUES(";
	my @L=map { "'$_'"; } (values %VALUES);
	$cmd.=join(",",@L) . ");";

	$DBH->do("BEGIN TRANSACTION");
	$DBH->do($cmd);
	$rc=$DBH->errstr;
	if(defined($rc)) {
		$cldb_errcode=12;
		$cldb_errstr="Error occured whilst performing:\n$cmd\n\nError: $rc\n";
		$DBH->do("ROLLBACK TRANSACTION");
		return 0;
	} else {
		if(exists($::records_postadd{$ARG_table})) {
			($rc,$str)=&{$::records_postadd{$ARG_table}}($self,$ARG_table,%VALUES);
			if($rc) {
				$cldb_errcode=12;
				$cldb_errstr="Error occured whilst performing post add update:\n$str";
				$DBH->do("ROLLBACK TRANSACTION");
				return 0;
			}
		}
	}
	$DBH->do("END TRANSACTION");
	$DBH->commit;
	return 1;
}

#########################################################################
# Below are verification methods that should not be used directly -	#
# they are called via the add_verified_record.				#
#########################################################################

sub is_unique($$$$) {
my ($table,$field,$value,$ref)=@_;
my ($sth,$cmd,$rc);

	$cmd="SELECT * FROM $table WHERE $field = '$value';";
	$sth=$DBH->prepare($cmd);
	if(!defined($sth)) {
		$rc=$DBH->errstr;
		return(1,"Error attempting to query table $table:\n$rc");
	}
	if(! $sth->execute()) {
		return(1,"Unable to execute '$cmd':\n".$DBH->errstr);
	}
	if(defined($sth->fetchrow_hashref)) {
		return(1,"Value '$value' already exists in column '$field' in table '$table'.");
	}
	return(0,undef);
}

sub is_nowhitespace($$$$) {
my ($table,$field,$value,$ref)=@_;

	cluck("here!");
	if($value =~ /\s+/) {
		return(1,"Value '$value' for column '$field' must not contain white space.");
	}
	return(0,undef);
}

sub is_mailid($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^[\w\-\.]+@([\w\-]+\.{0,1}){1,4}$/i &&
		$value =~ /[^\.]+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid Internet email address.");
}

sub encode_key($$$$) {
my ($table,$field,$value,$ref)=@_;

	my $ctx=Digest::SHA1->new;
	$ctx->add($value);
	my $hex=$ctx->hexdigest;
	return(0,$hex);
}

sub is_unixname($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^[\w\-]+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid UNIX filename.");
}

sub is_yesno($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^(y|yes|n|no)$/i) {
		return(0,uc(substr($value,0,1)));
	}
	return(1,"Value '$value' is not valid for a 'yes/no' column.");
}

sub is_valid_date($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ m{^\d{2}/\d{2}/\d{4}$}) {
		return(0,undef);
	}
	return(1,"Date must be in format 'DD/MM/YYYY'");
}

sub is_integer($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^\d+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid integer.");
}

sub is_number($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^\d+$/ || $value =~ /\d*\.\d+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid number.");
}

sub is_valid_nettype($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^failover$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid network type.");
}

sub is_known_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_known_cluster not yet implemented.");
}

sub is_unique_app_in_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_unique_app_in_cluster not yet implemented.");
}

sub is_valid_failover_type($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^normal|force$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid failover type.");
}

sub is_sha1($$$$) {
my ($table,$field,$value,$ref)=@_;
	if($value =~ /^[a-f0-9]{40}$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid SHA1 hex value.");
}

#########################################################################
# App preference can be blank, LEAST_LOAD or a name of a node.		#
#########################################################################

sub is_valid_app_preference($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_valid_script($$$$) {
my ($table,$field,$value,$ref)=@_;

	if(! -e "$value") {
		return(2,"Script '$value' not found locally.");
	}
	return(0,undef);
}

sub is_netmask($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_ip_addr($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_4_or_6($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_cluster_app($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_cluster_app not yet implemented.");
}

sub is_valid_cluster_event($$$$) {
my ($table,$field,$value,$ref)=@_;
my @events=qw{node.daemon_warn node.daemon_error node.join node.leave 
	node.down app.start app.endapp.failed};

	if(grep {/^$value$/i} @events) {
		return(0,lc($value));
	}
	return(2,"Cluster event '$value' is not valid.");
}

sub is_valid_cluster_event_type($$$$) {
my ($table,$field,$value,$ref)=@_;
my @events=qw{email log socket cmd};

	if(grep {/^$value$/i} @events) {
		return(0,lc($value));
	}
	return(2,"Cluster event type '$value' is not valid.");
}

sub is_supported_fs($$$$) {
my ($table,$field,$value,$ref)=@_;
my @FS=qw{ext2 ext3 ext4 xfs jfs reiserfs vxfs};

	if(scalar(grep {/^$value$/i} @FS)) {
		return(0,lc($value));
	}
	return(2,"File system type '$value' has not been validated against Linuxha.net V2!");
}

sub is_existing_vg($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_existing_vg not yet implemented.");
}

sub is_unique_in_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	# Is the VG not in use on this node for any other app/cluster
	# Does the VG exist at all.
	die("Routine is_unique_in_cluster not yet implemented.");
}

sub is_existing_lv($$$$) {
my ($table,$field,$value,$ref)=@_;

	# Does the VG/LV exist locally?
	# Does the LV_meta exist and is 128Mb in size?
	die("Routine is_existing_lv not yet implemented.");
}

sub is_host_or_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;
my @FS=qw{host cluster};

	if(scalar(grep {/^$value$/i} @FS)) {
		return(0,lc($value));
	}
	return(1,"Lock type '$value' is unknown.");
}

sub is_valid_storagespec($$$$) {
my @T=qw(vxfs lvm drbd);

	if(scalar(grep {/^$value$/i} @T)) {
		return(0,lc($value));
	}
	return(1,"Storage specification type '$value' is unknown.");
}

1;

